Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH5/SRC/BOUNCE2.FRM

Visual Basic Form | 1997-01-08 | 12.8 KB | 413 lines

VERSION 4.00
Begin VB.Form BounceForm
   Caption         =   "Bounce1"
   ClientHeight    =   5235
   ClientLeft      =   1320
   ClientTop       =   1110
   ClientWidth     =   6870
   Height          =   5925
   Left            =   1260
   LinkTopic       =   "Form1"
   ScaleHeight     =   349
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   458
   Top             =   480
   Width           =   6990
   Begin VB.OptionButton Method
      Caption         =   "Erase and Redraw"
      Height          =   255
      Index           =   3
      Left            =   3600
      TabIndex        =   10
      Top             =   4920
      Width           =   1695
   End
   Begin VB.OptionButton Method
      Caption         =   "SetBitmapBits"
      Height          =   255
      Index           =   2
      Left            =   3600
      TabIndex        =   9
      Top             =   4560
      Width           =   1695
   End
   Begin VB.OptionButton Method
      Caption         =   "Save and Restore"
      Height          =   255
      Index           =   1
      Left            =   1920
      TabIndex        =   8
      Top             =   4920
      Width           =   1695
   End
   Begin VB.OptionButton Method
      Caption         =   "Cls"
      Height          =   255
      Index           =   0
      Left            =   1920
      TabIndex        =   7
      Top             =   4560
      Value           =   -1  'True
      Width           =   1695
   End
   Begin VB.PictureBox Court
      AutoRedraw      =   -1  'True
      Height          =   4455
      Left            =   0
      ScaleHeight     =   293
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   453
      TabIndex        =   6
      Top             =   0
      Width           =   6855
   End
   Begin VB.PictureBox OffScreen
      AutoRedraw      =   -1  'True
      Height          =   615
      Left            =   6240
      ScaleHeight     =   37
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   37
      TabIndex        =   5
      Top             =   4560
      Visible         =   0   'False
      Width           =   615
   End
   Begin VB.TextBox FPSText
      Height          =   285
      Left            =   1440
      TabIndex        =   3
      Text            =   "20"
      Top             =   4920
      Width           =   375
   End
   Begin VB.TextBox BallsText
      Height          =   285
      Left            =   1440
      TabIndex        =   2
      Text            =   "20"
      Top             =   4560
      Width           =   375
   End
   Begin VB.CommandButton CmdStart
      Caption         =   "Start"
      Default         =   -1  'True
      Height          =   495
      Left            =   5400
      TabIndex        =   0
      Top             =   4620
      Width           =   855
   End
   Begin VB.Label Label1
      Caption         =   "Frames per second:"
      Height          =   255
      Index           =   0
      Left            =   0
      TabIndex        =   4
      Top             =   4920
      Width           =   1455
   End
   Begin VB.Label Label1
      Caption         =   "Number of balls:"
      Height          =   255
      Index           =   1
      Left            =   0
      TabIndex        =   1
      Top             =   4560
      Width           =   1455
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
Attribute VB_Name = "BounceForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Const METHOD_CLS = 0
Const METHOD_SAVE_AND_RESTORE = 1
Const METHOD_SETBITS = 2
Const METHOD_ERASE_AND_REDRAW = 3
Dim DrawingMethod As Integer
Dim xmax As Integer
Dim ymax As Integer
Dim StartX As Integer
Dim StartY As Integer
Dim NumBalls As Integer
Dim BallR() As Integer
Dim BallX() As Integer
Dim BallY() As Integer
Dim BallDx() As Integer
Dim BallDy() As Integer
Dim BallClr() As Long
Dim Playing As Boolean
' ************************************************
' Generate some random data.
' ************************************************
Sub InitData()
Dim ball As Integer
Dim r As Integer
Dim clr As Integer
    ' See how many balls there should be.
    If Not IsNumeric(BallsText.Text) Then Exit Sub
    NumBalls = CInt(BallsText.Text)
    If NumBalls < 1 Then Exit Sub
    ReDim BallR(1 To NumBalls)
    ReDim BallX(1 To NumBalls)
    ReDim BallY(1 To NumBalls)
    ReDim BallDx(1 To NumBalls)
    ReDim BallDy(1 To NumBalls)
    ReDim BallClr(1 To NumBalls)
    ' Set the initial ball data.
    For ball = 1 To NumBalls
        r = Int(10 * Rnd + 5)
        BallR(ball) = r
        BallX(ball) = Int((xmax - r + 1) * Rnd)
        BallY(ball) = Int((ymax - r + 1) * Rnd)
        BallDx(ball) = Int(21 * Rnd - 10)
        BallDy(ball) = Int(21 * Rnd - 10)
        clr = Int(15 * Rnd)
        If clr >= 7 Then clr = clr + 1
        BallClr(ball) = QBColor(clr)
    Next ball
    StartX = BallX(1)
    StartY = BallY(1)
End Sub
' ************************************************
' Reinitialize the data.
' ************************************************
Private Sub BallsText_Change()
    InitData
End Sub
' ************************************************
' Start the animation.
' ************************************************
Private Sub CmdStart_Click()
    If Playing Then
        Playing = False
        CmdStart.Caption = "Stopped"
        CmdStart.Enabled = False
    Else
        CmdStart.Caption = "Stop"
        Playing = True
        PlayData
        Playing = False
        CmdStart.Caption = "Start"
        CmdStart.Enabled = True
    End If
End Sub
' ************************************************
' Play the animation.
' ************************************************
Sub PlayData()
Dim mpf As Long     ' Milliseconds per frame.
Dim ball As Integer
Dim next_time As Long
Dim old_style As Integer
Dim moving As Integer
Dim r As Integer
Dim r2 As Integer
Dim D As Integer
Dim oldx As Integer
Dim oldy As Integer
Dim newx As Integer
Dim newy As Integer
Dim i As Integer
Dim j As Integer
Dim frames As Integer
Dim start_time As Single
Dim stop_time As Single
Dim bm As BITMAP
Dim hbm As Integer
Dim status As Long
Dim wid As Long
Dim hgt As Long
Dim num_bits As Long
Dim bytes() As Byte
    ' Set FillStyle to vbSolid.
    old_style = Court.FillStyle
    Court.FillStyle = vbSolid
    ' See how fast we should go.
    If Not IsNumeric(FPSText.Text) Then _
        FPSText.Text = "10"
    mpf = 1000 \ CLng(FPSText.Text)
    ' Erase the screen.
    Court.Line (0, 0)-(xmax, ymax), Court.BackColor, BF
    ' Draw the background balls.
    moving = 1
    For ball = 2 To NumBalls
        Court.FillColor = BallClr(ball)
        Court.Circle (BallX(ball), BallY(ball)), _
            BallR(ball), BallClr(ball)
    Next ball
    ball = moving
    BallX(moving) = StartX
    BallY(moving) = StartY
    oldx = StartX
    oldy = StartY
    newx = StartX
    newy = StartY
    BallDx(moving) = 10
    BallDy(moving) = 10
    r = BallR(moving)
    D = 2 * r + 1
    ' Prepare for the animation.
    Select Case DrawingMethod
        Case METHOD_CLS
            ' Make the picture the background.
            Court.Picture = Court.Image

        Case METHOD_SAVE_AND_RESTORE
            ' Make the picture the background.
            Court.Picture = Court.Image

            ' Save the screen contents where
            ' the ball will go.
            OffScreen.Cls
            OffScreen.PaintPicture Court.Picture, _
                0, 0, D, D, oldx - r, oldy - r, D, D
            OffScreen.Picture = OffScreen.Image

        Case METHOD_SETBITS
            ' Get the background image pixels.
            hbm = Court.Image
            status = GetObject(hbm, BITMAP_SIZE, bm)
            wid = bm.bmWidthBytes
            hgt = bm.bmHeight
            num_bits = wid * hgt
            ReDim bytes(1 To wid, 1 To hgt)
            status = GetBitmapBits(hbm, num_bits, bytes(1, 1))

    End Select
    ' Start the animation.
    next_time = GetTickCount()
    start_time = Timer
    Do While Playing
        frames = frames + 1

        ' Move the ball.
        newx = oldx + BallDx(moving)
        If newx < r Then
            newx = 2 * r - newx
            BallDx(moving) = -BallDx(moving)
        ElseIf newx > xmax - r Then
            newx = 2 * (xmax - r) - newx
            BallDx(moving) = -BallDx(moving)
        End If

        newy = oldy + BallDy(moving)
        If newy < r Then
            newy = 2 * r - newy
            BallDy(moving) = -BallDy(moving)
        ElseIf newy > ymax - r Then
            newy = 2 * (ymax - r) - newy
            BallDy(moving) = -BallDy(moving)
        End If

        ' Wait until it's time for the next frame.
        next_time = next_time + mpf
        WaitTill next_time

        Select Case DrawingMethod
            Case METHOD_CLS
                ' Erase the screen.
                Court.Cls

                ' Draw the ball in its new location.
                Court.FillColor = BallClr(moving)
                Court.Circle (newx, newy), _
                    r, BallClr(moving)

            Case METHOD_SAVE_AND_RESTORE
                ' Erase the area where the ball is.
                Court.PaintPicture OffScreen.Picture, _
                    oldx - r, oldy - r, D, D, 0, 0, D, D

                ' Save the screen contents where
                ' the ball will go.
                OffScreen.PaintPicture Court.Picture, _
                    0, 0, D, D, newx - r, newy - r, D, D
                OffScreen.Picture = OffScreen.Image

                ' Draw the ball in its new location.
                Court.FillColor = BallClr(moving)
                Court.Circle (newx, newy), _
                    r, BallClr(moving)

            Case METHOD_SETBITS
                ' Erase using SetBitmapBits.
                status = SetBitmapBits(hbm, num_bits, bytes(1, 1))

                ' Draw the ball in its new location.
                Court.FillColor = BallClr(moving)
                Court.Circle (newx, newy), _
                    r, BallClr(moving)

            Case METHOD_ERASE_AND_REDRAW
                ' Erase the moving ball.
                Court.FillColor = Court.BackColor
                Court.Circle (oldx, oldy), _
                    r, Court.BackColor

                ' Redraw any balls that overlap
                ' the moving ball.
                For i = 2 To NumBalls
                    r2 = r + BallR(i)
                    If Abs(BallX(i) - oldx) <= r2 And _
                       Abs(BallY(i) - oldy) <= r2 Then
                        Court.FillColor = BallClr(i)
                        Court.Circle _
                            (BallX(i), BallY(i)), _
                            BallR(i), BallClr(i)
                    End If
                Next i

                ' Draw the ball in its new location.
                Court.FillColor = BallClr(moving)
                Court.Circle (newx, newy), _
                    r, BallClr(moving)
        End Select

        oldx = newx
        oldy = newy
    Loop
    stop_time = Timer
    MsgBox "Displayed" & Str$(frames) & _
        " frames in " & _
        Format$(stop_time - start_time, "0.00") & _
        " seconds (" & _
        Format$(frames / (stop_time - start_time), "0.00") & _
        " FPS)."
    ' Restore the old FillStyle.
    Court.FillStyle = old_style
End Sub
' ************************************************
' Make the ball court nice and big.
' ************************************************
Private Sub Form_Resize()
Const GAP = 3
    FPSText.Top = ScaleHeight - GAP - FPSText.Height
    Label1(0).Top = FPSText.Top
    BallsText.Top = FPSText.Top - GAP - BallsText.Height
    Label1(1).Top = BallsText.Top
    CmdStart.Top = (BallsText.Top + FPSText.Top + FPSText.Height - CmdStart.Height) / 2
    Court.Move 0, 0, ScaleWidth, BallsText.Top - GAP
    xmax = Court.ScaleWidth - 1
    ymax = Court.ScaleHeight - 1
    InitData
End Sub
Private Sub Form_Unload(Cancel As Integer)
    End
End Sub
' ************************************************
' Save the selected drawing method.
' ************************************************
Private Sub Method_Click(Index As Integer)
    DrawingMethod = Index
End Sub
Private Sub mnuFileExit_Click()
    Unload Me
End Sub